QRZ! Ham Radio 6/QRZ Ham Radio Callsign Database - Volume 6.iso/mac/files/f6fbb/ping0723.lzh/PING.PAS

Pascal/Delphi Source File | 1992-07-23 | 7KB | 261 lines

program PING;

{ OH3NWQ  turbo pascal 6.0                     }
{                                              }
{ to study the route and forwarding times      }
{                                              }
{ syntax:                                      }
{        SP PING @ OH3RBR.FIN.EU               }
{        @ OH3NWQ.FIN.EU                       }
{        This text is sent back to you         }
{                                              }
{ or:                                          }
{        SP PING @ OH3RBR.FIN.EU               }
{        OH3NWQ.FIN.EU                         }
{        This text is sent back to you         }
{                                              }
{ if the return bbs is not given in the        }
{ title, this programme tries to find it       }
{ from the R:9... lines.                       }
{ I.e. it picks the last one of them.          }

uses dos;

type
    pitkajono = string[80];

const
    copyright = 'PING for FBB 5.14 v.1992-07-23 by OH3NWQ @ OH3RBR.FIN.EU';

var
   kutsu,mista,mihin,
   missa,tiedot,palautus         : pitkajono;


function merkiksi(jono : string) : char;
begin
  merkiksi := jono[1];
end;


function r_rivit(mista : string) : string;
var
   rivi, vrivi   : pitkajono;
   sisaan        : text;
   paikka        : integer;

begin
     assign(sisaan,mista);
     reset (sisaan);
     readln(sisaan,rivi);
     readln(sisaan,rivi);

     repeat
         begin
             vrivi := rivi;
             readln(sisaan,rivi);
         end;
     until ((copy(rivi,1,3) <> 'R:9') or (eof(sisaan)));

     paikka := pos('@:',vrivi);

     if paikka = 0 then halt(0);

     vrivi   := copy(vrivi,paikka+2,80);
     vrivi   := copy(vrivi,1,pos(' ',vrivi));

     r_rivit := vrivi;
     close(sisaan);
end;


procedure lue_parametrit(var tiedosto,hakemisto:pitkajono);

begin
     tiedosto   := 'MAIL.IN';
     hakemisto  := 'C:\FBB\';
end;

function leadingzero(sana : word) : string;
var
   jono : string;
begin
     str(sana:0,jono);
     if length(jono) = 1 then
        jono := '0' + jono;
     leadingzero := jono;
end;


procedure hae_osoite(hmista : pitkajono ; var vastausos : pitkajono);

var
   sisaan                           : text;
   ekarivi, tokarivi, apu           : pitkajono;
   paikka, pituus, k, kir, nro, pis : integer;
   merkki                           : char;
   parsittava                       : boolean;

begin
     apu        := '';
     parsittava := false;
     kir        := 0;
     nro        := 0;
     pis        := 0;
     vastausos  := 'SP ';

     assign(sisaan,hmista);
     reset (sisaan);
     readln(sisaan,ekarivi);
     readln(sisaan,tokarivi);
     close (sisaan);

     paikka := pos('<',ekarivi);
     pituus := length(ekarivi);

     for k := paikka+1 to pituus do
         begin
            if copy(ekarivi,k,1) > ' ' then
               vastausos := vastausos+copy(ekarivi,k,1);
         end;

     pituus := length(tokarivi);

     for k := 1 to pituus do
        if copy(tokarivi,k,1) > ' ' then
           apu := apu+copy(tokarivi,k,1);

     while pos('@',apu)>0 do
        apu := copy(apu,pos('@',apu)+1,80);

     pituus := length(apu);

     for k := 1 to pituus do
     begin
          merkki := merkiksi(copy(apu,k,1));
          case merkki of '0'..'9'        : inc(nro);
                         'A'..'Z'        : inc(kir);
                         'a'..'z'        : inc(kir);
                         '.'             : inc(pis);
                         '*'             : parsittava := true;
                         '?'             : parsittava := true;
                         '$'             : parsittava := true;
                         '<'             : parsittava := true;
                         chr(1)..chr(31) : parsittava := true;
                         '['..'`'        : parsittava := true;
                         '{'..chr(255)   : parsittava := true;
                         end;
     end;

     if (nro = 0) then parsittava := true;
     if (kir = 0) then parsittava := true;

     if (parsittava = false) then
     begin
         if pis = 0 then
            begin
                if ((pituus >= 3) and ((nro = 1) or
                   (nro = 2)) and (kir >= 2))
                   then vastausos := vastausos + ' @ ' + apu;
            end
            else
            begin
                if ((pituus >= 10) and (nro >= 1) and
                   (kir >= 7) and (kir >= pis))
                   then vastausos := vastausos + ' @ ' + apu;
            end;
     end else
     begin
            vastausos := vastausos + ' @ ' + r_rivit(hmista);
     end;
end;


procedure aloita_vastaus(osoite,imprtfile,polku : pitkajono);

const
  days : array [0..6] of string[9] =
         ('Sunday','Monday','Tuesday','Wednesday',
         'Thursday','Friday','Saturday');

var
   ulos               : text;
   ho, mi, se, hund,
   ye, mo, da, dow    : word;

begin

     if fsearch(imprtfile,polku) = '' then
        begin
           assign(ulos,polku+imprtfile);
           rewrite(ulos);
           close(ulos);
        end;

     assign(ulos,polku+imprtfile);
     append(ulos);

     writeln(ulos,osoite);
     writeln(ulos,'RE: * Ping server *');
     writeln(ulos);
     writeln(ulos,copyright);
     gettime(ho,mi,se,hund);
     getdate(ye,mo,da,dow);
     writeln(ulos,'Pinged at ', days[dow],', ',ye:0, '-',
                  leadingzero(mo), '-',leadingzero(da),'  ',
                  leadingzero(ho),':',leadingzero(mi),':',
                  leadingzero(se),'.',leadingzero(hund));
     writeln(ulos);
     close(ulos);
end;


procedure pingaa_rivit(mikatied,imprtfile,polku : pitkajono);

var
   sisaan, ulos    : text;
   rivi            : pitkajono;

begin

     assign(ulos,polku+imprtfile);
     append(ulos);

     assign(sisaan,mikatied);
     reset (sisaan);

     repeat
           begin
                 readln  (sisaan,rivi);
                 rivi := copy(rivi,1,73);
                 if not (copy(rivi,1,3)='/EX') then
                        writeln (ulos,'PING> ',rivi);
           end;
     until (eof(sisaan)) or (copy(rivi,1,3)='/EX');

     writeln(ulos);
     writeln(ulos,'End of PING - I''m alive.');
     writeln(ulos,'/EX');
     close  (ulos);
     close  (sisaan);
end;


begin   {Pääohjelma}

     if paramcount < 1 then
        begin
             writeln(copyright);
             writeln('Ping is a server for a FBB 5.14 mailbox');
             halt(0);
        end;

     mista := paramstr(1);

     lue_parametrit(mihin,missa);
     hae_osoite(mista,palautus);

     aloita_vastaus(palautus,mihin,missa);
     pingaa_rivit(mista,mihin,missa);
end.